home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Internet Surfer: Getting Started
/
Internet Surfer - Getting Started (Wayzata Technology)(7231)(1995).bin
/
pc
/
mac
/
bonus
/
peter_le
/
chat__
/
chat.p
< prev
Wrap
Text File
|
1992-11-28
|
15KB
|
623 lines
{$I-}
program Chat;
{ This program was written by Peter N Lewis, Mar 1992 in THINK Pascal 4.0.1 }
{ You may use this source in your own free/shareware projects as long as you acknowledge me }
{ in your About box and documentation files. You may include it in commercial products }
{ only if I explicitly allow it. }
uses
TCPStuff, TCPConnections, MyTypes, MyUtils, MyLists, MyStripTelnetCodes;
const
globalStrhResID = 128;
channelStrhResID = 129;
commandStrhResID = 130;
max_channel = 10;
bad_rn = -1;
type
strings = (noIndex, portIndex, irclogname, irclogtype, quitnowIndex, {}
howdullIndex, welcomeIndex, badChannelIndex, enternameIndex,{}
loggedinatIndex, youneedanameIndex, nameinuseIndex,{}
welcome2index1, welcomewarningIndex, welcome2index2, hasenteredIndex, {}
closingdownIndex, closingdownatIndex, helpIndex, helpIndex2,{}
byebyeIndex, colonIndex, hasleftIndex,{}
echoIndex, badparamIndex, badvariableIndex, {}
lastIndex);
commands = (C_None, C_Quit, C_List, C_Action1, C_Action2, C_Set);
type
infoRecord = record
cp: connectionIndex;
tp: TCPConnectionPtr;
state: (S_unconnected, S_GettingChannel, S_GettingName, S_GettingPassword, S_Connected, S_Closed);
buffer: str255;
name: str31;
channel: str31;
channel_index: integer;
wason: boolean;
echotoyou: boolean;
requirequote: boolean;
end;
infoPtr = ^infoRecord;
var
lh: listHead;
quitNow: boolean;
connected: integer;
port: integer;
dolog: boolean;
logrns: array[1..max_channel] of integer;
function GetGlobalString (n: strings): str255;
var
s: str255;
begin
GetIndString(s, globalStrhResID, ord(n));
GetGlobalString := s;
end;
procedure CreatePC;
var
p: infoPtr;
oe: OSErr;
begin
p := infoPtr(Newptr(SizeOf(infoRecord)));
p^.state := S_unconnected;
p^.channel := '';
p^.channel_index := 0;
p^.wason := false;
p^.echotoyou := false;
p^.requirequote := false;
oe := NewPassiveConnection(p^.cp, Minimum_TCPBUFFERSIZE, port, 0, 0, p);
AddTail(lh, p);
end;
procedure DestroyPC (p: infoPtr);
var
item: listItem;
lp: infoPtr;
begin
if FindItem(lh, p, item) then begin
DisposPtr(ptr(p));
DeleteItem(item, p);
end;
end;
procedure StartLog (var info: infoRecord; name: str255);
var
oe, ooe: OSErr;
logrn: integer;
begin
oe := HCreate(-1, 2, name, GetGlobalString(irclogtype), 'TEXT');
oe := HOpen(-1, 2, name, fsWrPerm, logrn);
if oe = noErr then begin
oe := SetFPos(logrn, fsFromLEOF, 0);
if oe <> noErr then
ooe := FSClose(logrn);
end;
if oe = noErr then
logrns[info.channel_index] := logrn;
end;
procedure StopLog (var info: infoRecord);
var
oe: OSErr;
begin
if logrns[info.channel_index] <> bad_rn then begin
oe := FSClose(logrns[info.channel_index]);
logrns[info.channel_index] := bad_rn;
end;
end;
procedure StopAllLogs;
var
oe: OSErr;
i: integer;
begin
for i := 1 to max_channel do
if logrns[i] <> bad_rn then
oe := FSClose(logrns[i]);
end;
procedure Log (var info: infoRecord; s: str255);
var
count: longInt;
oe: OSErr;
begin
{$PUSH}
{$R-}
if s[length(s)] = lf then
s[0] := chr(ord(s[0]) - 1);
count := length(s);
oe := FSWrite(logrns[info.channel_index], count, @s[1]);
{$POP}
end;
function EnterChannel (var info: infoRecord): boolean;
var
i: integer;
s: str255;
begin
i := 1;
info.channel_index := 0;
GetIndString(s, channelStrhResID, i * 2 - 1);
while (i <= max_channel) & (s <> '') do begin
if IUEqualString(s, info.channel) = 0 then begin
info.channel_index := i;
if logrns[i] = bad_rn then begin
GetIndString(s, channelStrhResID, i * 2);
if s <> '' then begin
StartLog(info, s);
end;
end;
leave;
end;
i := i + 1;
GetIndString(s, channelStrhResID, i * 2 - 1);
end;
EnterChannel := info.channel_index > 0;
end;
procedure LeaveChannel (var p: infoPtr);
var
item: listItem;
lp: infoPtr;
someoneelse: boolean;
begin
if p^.channel_index <> 0 then begin
someoneelse := false;
ReturnHead(lh, item);
while not IsTail(item) do begin
Fetch(item, lp);
if (lp <> p) & (lp^.channel_index = p^.channel_index) then begin
someoneelse := true;
leave;
end;
MoveToNext(item);
end;
if not someoneelse then
StopLog(p^);
end;
end;
function GetLine (tcpc: TCPConnectionPtr; value: longInt; var buffer: str255): boolean;
var
len: longInt;
gotlf: boolean;
i, j: integer;
begin
GetLine := false;
len := length(buffer);
{$PUSH}
{$R-}
if TCPReceiveUpTo(tcpc, 10, 1, @buffer[1], SizeOf(buffer) - 1, len, gotlf) = noErr then begin
i := 1;
j := 1;
while (i <= len) do begin
case buffer[i] of
cr, lf:
i := i + 1;
bs, del: begin
i := i + 1;
if j > 1 then
j := j - 1;
end;
otherwise begin
buffer[j] := buffer[i];
i := i + 1;
j := j + 1;
end;
end;
end;
buffer[0] := chr(j - 1);
GetLine := gotlf;
end;
{$POP}
end;
procedure SendString (tcpc: TCPCOnnectionPtr; s: str255);
var
oe: OSErr;
begin
{$PUSH}
{$R-}
oe := TCPSendAsync(tcpc, @s[1], length(s), true, nil);
{$POP}
end;
function OtherOnChannel (p, lp: infoPtr): boolean;
begin
OtherOnChannel := (lp <> p) & (lp^.state = S_connected) & (lp^.channel_index = p^.channel_index);
end;
function WeakOtherOnChannel (p, lp: infoPtr): boolean;
begin
WeakOtherOnChannel := ((lp <> p) or (p^.echotoyou)) & (lp^.state = S_connected) & (lp^.channel_index = p^.channel_index);
end;
procedure SendExceptString (p: infoPtr; s: str255);
var
item: listItem;
lp: infoPtr;
tcpc: TCPConnectionPtr;
begin
Log(p^, s);
ReturnHead(lh, item);
while not IsTail(item) do begin
Fetch(item, lp);
if WeakOtherOnChannel(p, lp) then begin
GetConnectionTCPC(lp^.cp, tcpc);
SendString(tcpc, s);
end;
MoveToNext(item);
end;
end;
type
SEFormat = (SE_Speak, SE_Action, SE_Notice);
procedure SendExceptNameString (p: infoPtr; s: str255; format: SEFormat);
var
colon: str15;
i, linelen: integer;
out: str255;
begin
case format of
SE_Speak:
colon := ': ';
SE_Action:
colon := ' ';
SE_Notice:
colon := ' ';
end;
linelen := 72 - length(colon) - length(p^.name);
for i := 1 to length(s) do
if s[i] = tab then
s[i] := spc;
repeat
if length(s) > 78 - length(colon) - length(p^.name) then begin
i := linelen;
while (i > 0) and (s[i] <> spc) do begin
i := i - 1;
end;
while (i > 0) and (s[i] = spc) do begin
i := i - 1;
end;
if i < 1 then
i := linelen;
end
else
i := length(s);
out := concat(p^.name, colon, copy(s, 1, i));
if format = SE_Notice then
out := concat('*', out, '*');
SendExceptString(p, concat(out, cr, lf));
i := i + 1;
while (i <= length(s)) and (s[i] = spc) do begin
i := i + 1;
end;
s := copy(s, i, 255);
until s = '';
end;
procedure FixName (var s: str31);
var
i: integer;
begin
for i := 1 to length(s) do
if not (s[i] in ['a'..'z', 'A'..'Z', '0'..'9', '-', '$', '/']) then
s[i] := '_';
end;
function NameInUse (p: infoPtr): boolean;
var
item: listItem;
lp: infoPtr;
tcpc: TCPConnectionPtr;
begin
NameInUse := false;
ReturnHead(lh, item);
while not IsTail(item) do begin
Fetch(item, lp);
if OtherOnChannel(p, lp) then begin
if IUEqualString(lp^.name, p^.name) = 0 then begin
NameInUse := true;
leave;
end;
end;
MoveToNext(item);
end;
end;
procedure SendExceptNames (p: infoPtr);
var
item: listItem;
lp: infoPtr;
first: boolean;
len: integer;
begin
first := true;
len := 0;
ReturnHead(lh, item);
while not IsTail(item) do begin
Fetch(item, lp);
if OtherOnChannel(p, lp) then begin
if first then
first := false
else begin
SendString(p^.tp, ', ');
len := len + 2;
end;
if len + length(lp^.name) > 75 then begin
SendString(p^.tp, concat(cr, lf));
len := 0;
end;
SendString(p^.tp, lp^.name);
len := len + length(lp^.name);
end;
MoveToNext(item);
end;
if first then
SendString(p^.tp, concat(GetGlobalString(howdullIndex), cr, lf))
else
SendString(p^.tp, concat(cr, lf));
end;
function GetTimeStr: str255;
var
st, sd: str255;
date: longInt;
begin
GetDateTime(date);
IUDateString(date, abbrevDate, sd);
IUTimeString(date, false, st);
GetTimeStr := concat(st, ', ', sd);
end;
procedure GetWord (var line, word: str255);
var
p: integer;
begin
p := Pos(' ', line);
if p > 0 then begin
word := copy(line, 1, p - 1);
Delete(line, 1, p);
end
else begin
word := line;
line := '';
end;
end;
function SetBoolean (var line: str255; var b: boolean): boolean;
begin
UpCaseString(line);
SetBoolean := false;
if line <> '' then begin
case line[1] of
'Y', 'E', 'T': begin
b := true;
SetBoolean := true;
end;
'N', 'D', 'F': begin
b := false;
SetBoolean := true;
end;
'O': begin
if line = 'ON' then begin
b := true;
SetBoolean := true;
end
else if line = 'OFF' then begin
b := false;
SetBoolean := true;
end;
end;
otherwise
;
end;
end;
end;
procedure DoCommand (var p: infoPtr; line: str255);
var
ch: char;
i, ps: integer;
cmd: commands;
s, thecmd: str255;
begin
ch := nul;
if line <> '' then
ch := line[1];
case ch of
'/': begin
Delete(line, 1, 1);
if line = GetGlobalString(quitnowIndex) then begin
quitNow := true;
SendString(p^.tp, concat(GetGlobalString(closingdownIndex), cr, lf));
SendExceptString(p, concat(GetGlobalString(closingdownatIndex), GetTimeStr, cr, lf));
{ Should really send to everyone everywhere, but too much effort }
end
else begin
GetWord(line, thecmd);
i := 1;
cmd := C_None;
GetIndString(s, commandStrhResID, i * 2 - 1);
while s <> '' do begin
if IUEqualString(thecmd, s) = 0 then begin
cmd := commands(i);
leave;
end;
i := i + 1;
GetIndString(s, commandStrhResID, i * 2 - 1);
end;
case cmd of
C_Quit: begin
SendString(p^.tp, concat(GetGlobalString(byebyeIndex), cr, lf));
p^.echotoyou := false;
p^.state := S_Closed;
CloseConnection(p^.cp);
end;
C_List: begin
SendExceptNames(p);
end;
C_Action1, C_Action2: begin
SendExceptNameString(p, line, SE_Action);
end;
C_Set: begin
GetWord(line, thecmd);
if IUEqualString(thecmd, GetGlobalString(echoIndex)) = 0 then begin
if not SetBoolean(line, p^.echotoyou) then
SendString(p^.tp, concat(GetGlobalString(badparamIndex), cr, lf));
end
else begin
SendString(p^.tp, concat(GetGlobalString(badvariableIndex), cr, lf));
end;
end;
otherwise begin
SendString(p^.tp, concat(GetGlobalString(helpIndex), cr, lf));
i := 1;
GetIndString(s, commandStrhResID, i * 2);
while s <> '' do begin
if s <> '<NONE>' then
SendString(p^.tp, concat(s, cr, lf));
i := i + 1;
GetIndString(s, commandStrhResID, i * 2);
end;
SendString(p^.tp, concat(GetGlobalString(helpIndex2), cr, lf));
end;
end;
end;
end;
otherwise begin
SendExceptNameString(p, line, SE_Speak);
end;
end;
end;
procedure WNE;
var
dummy: boolean;
er: eventRecord;
begin
dummy := WaitNextEvent(everyEvent, er, 15, nil);
if er.what = keyDown then
quitNow := true;
end;
function StackPtr: longInt;
inline
$2E8F;
var
cer: connectionEventRecord;
p: infoPtr;
oe: OSErr;
dummylong: longInt;
i: integer;
last: str255;
begin
SetApplLimit(ptr(StackPtr - 10000));
MaxApplZone;
MoreMasters;
if GetGlobalString(lastIndex) = '<LAST>' then begin
StringToNum(GetGlobalString(portIndex), dummylong);
port := dummylong;
for i := 1 to max_channel do
logrns[i] := bad_rn;
if InitConnections = noErr then begin
CreateList(lh);
CreatePC;
CreatePC;
connected := 0;
while not quitNow do begin
WNE;
if GetConnectionEvent(any_connection, cer) then
with cer do begin
p := infoPtr(dataptr);
with p^ do
case event of
C_Established: begin
connected := connected + 1;
state := S_GettingChannel;
buffer := '';
tp := tcpc;
SendString(tcpc, GetGlobalString(welcomeIndex));
CreatePC;
end;
C_CharsAvailable: begin
if GetLine(tcpc, value, buffer) then begin
StripTelnetCodes(buffer);
case state of
S_GettingChannel: begin
channel := buffer;
if EnterChannel(p^) then begin
SendString(tcpc, GetGlobalString(enternameIndex));
state := S_GettingName;
end
else begin
SendString(tcpc, concat(GetGlobalString(badChannelIndex), cr, lf));
state := S_Closed;
CloseConnection(connection);
end;
end;
S_GettingName: begin
Log(p^, concat(buffer, GetGlobalString(loggedinatIndex), GetTimeStr, cr, lf));
name := buffer;
FixName(name);
if name = '' then begin
SendString(tcpc, concat(GetGlobalString(youneedanameIndex), cr, lf));
state := S_Closed;
CloseConnection(connection);
end
else if NameInUse(p) then begin
SendString(tcpc, concat(GetGlobalString(nameinuseIndex), cr, lf));
state := S_Closed;
CloseConnection(connection);
end
else begin
SendString(tcpc, GetGlobalString(welcome2index1));
if logrns[channel_index] <> bad_rn then
SendString(tcpc, GetGlobalString(welcomewarningIndex));
SendString(tcpc, GetGlobalString(welcome2index2));
state := S_connected;
SendExceptNames(p);
SendExceptNameString(p, GetGlobalString(hasenteredIndex), SE_Notice);
wason := true;
end;
end;
S_GettingPassword: begin
end;
S_Connected: begin
DoCommand(p, buffer);
end;
otherwise
;
end;{case}
buffer := '';
end;{if getline}
StripTelnetCodes(buffer);
end;
C_Closing: begin
state := S_Closed;
CloseConnection(connection);
end;
C_Closed: begin
if wason then
SendExceptNameString(p, GetGlobalString(hasleftIndex), SE_Notice);
if channel_index > 0 then
LeaveChannel(p);
connected := connected - 1;
DestroyPC(p);
end;
end;
end;
end;
FinishEverything;
end;
end;
StopAllLogs;
end.
